home *** CD-ROM | disk | FTP | other *** search
/ Developer CD Series 1996 February: Tool Chest / Apple Developer CD Series Tool Chest February 1996 (Apple Computer)(1996).iso / Tool Chest / Development Tools & Languages / Macintosh Common Lisp Related / User Contributions / Matts-utils.sea / Matts-utils / fred-keystroke-macros.lisp / fred-keystroke-macros.lisp
Encoding:
Text File  |  1992-04-22  |  25.2 KB  |  658 lines  |  [TEXT/CCL2]
  1. ;;;
  2. ;;; fred-keystroke-macros.lisp
  3. ;;;
  4. ;;; Matthew Cornell
  5. ;;; Amherst, MA
  6. ;;; cornell@cs.umass.edu
  7. ;;;
  8.  
  9. #|
  10. ================================================================
  11. Purpose ========================================================
  12. ================================================================
  13. Defines functions and command bindings to do simple FRED keyboard macro
  14. recording.
  15.  
  16. Copyright © 1990-92 Matthew Cornell. All Rights Reserved. Send
  17. bugs, comments, questions, and fixes to cornell@cs.umass.edu.
  18.  
  19. Instructions:
  20. Just evaluate this buffer and use the "Macros" menu. It has three
  21. hierarchical menus that allow you to operate on any named macro, and below
  22. these three menus are these five items. To record a macro you start
  23. recording (with either the "Recording" menu item or with the keystroke
  24. bound to ed-start-kbd-macro), do your keystrokes, and end recording
  25. (in ways similar to starting). To use a macro you can run the last one
  26. recorded with the "Run New" menu item, run one that you named with the
  27. "Name Last" menu item, or run the last named macro you called, using the
  28. "Run Last" menu item.
  29.  
  30. Each menu's functions are listed next.
  31.  
  32.  
  33. Run        Runs a named macro.
  34. Insert        Inserts a named macro's definition (which you can then edit and
  35.         re-evaluate).
  36. Delete        Deletes a named macro.
  37. ---------
  38. Recording    Toggles recording. Has a checkmark during recording.
  39. Run New        Runs the last recorded macro.
  40. Name New    Attaches an asked-for name to the current last recorded macro and
  41.          saves it. The new macro will show then appear on the
  42.          hierarchical menus.
  43. ---------
  44. Run Last    Runs the last named macro (not the last recorded macro).
  45. Insert All    Runs the Insert function on all named macros. This function is
  46.          useful for saving macros to files.
  47. Delete All    Runs the Delete function on all named macros.
  48.  
  49.  
  50. ================================================================
  51. Status =========================================================
  52. ================================================================
  53. Implemented. Supports one level of recording but recursive macro
  54. invocations.
  55.  
  56. Bugs:
  57. - Macros run recursively within call-named-macro are saved as the last kbd
  58.    macro.
  59.    Fix: Added :save-as-last? keyword to it.
  60. - Removing the keystroke(s) that called ed-end-kbd-macro: I can't get
  61.    comtab-find-keys to find that function. How does ED-HELP do it?
  62.    Fix: I'm using cheezy-find-all-keys to help.
  63. - Fred prefixes: the first keystroke-name is run n times then the
  64.    others n times. Run-fred-command does this. How to turn off normal Fred
  65.    prefix handling?
  66.    Fix: Run-keystroke-name-list's :around method does an empty run using
  67.    #'identity, which satiates run-fred-command's need to prefix.
  68. - From neves@ils.nwu.EDU on 09-Mar-92 :
  69.   I have problems searching within a macro…
  70.  
  71.  
  72. Desires:
  73. - Call ed-end-kbd-macro cancel (c-g) is done and
  74.   *keystroke-recorder-installed?* .
  75. - Mini-buffer feedback of recording in progress. Fred seems to update it
  76.   without set-mini-buffer's help.
  77. - A way to record keystrokes that activate menus. MCL bypasses
  78.   Fred keystroke processing to do this.
  79. - To record menu selections (tricky for hierarchical menus?) .
  80. - Should warn if recording over unamed macro?
  81.  
  82.  
  83. ================================================================
  84. Change history =================================================
  85. ================================================================
  86.  5-May-91 mc    Created.
  87.  7-May-91 mc    Finished (with plenty of Bill's help getting Fred dispatching
  88.         to match the documentation).
  89.  8-May-91 mc    Fixed first two bugs with work-arounds.
  90.  8-May-91 mc    Added requires for the two patches.
  91. 10-May-91 mc    Added run last feature.
  92. 13-May-91 mc    Fixed last-macro bug in call-named-macro.
  93.  4-Aug-91 mc    Released.
  94. 14-Mar-92 mc    Fixed cheezy-find-all-keys and run-keystroke-name-list to use
  95.          new shadowing comtab representation.
  96.         Fixed run-keystroke-name-list :around to use
  97.          fred-prefix-numeric-value, which was named prefix-numeric-value .
  98. 17-Apr-92 mc    Fixed incremental search via Bill's code:
  99.         Included body of i-search-patch.lisp .
  100.         Redefined run-keystroke-name-list to bind
  101.          ccl::*processing-events* .
  102.         Fixed menu-update (eql *macro-menu*) to enable if a fred-mixin
  103.          item is in the front.
  104. 22-Apr-92 mc    Added call to fred-update in insert-all-kbd-macros (suggested
  105.          by cartier@math.uqam.ca .
  106.  
  107. |#
  108.  
  109.  
  110.  
  111.  
  112. ; i-search-patch.lisp
  113. ;
  114. ; i-search-do-keystroke no longer looks at *current-event*.
  115. ; This makes it possible to do keyboard macros that include c-s or c-r
  116.  
  117. (in-package :ccl)
  118.  
  119. (let ((*warn-if-redefine* nil)
  120.       (*warn-if-redefine-kernel* nil))
  121.  
  122. (defun i-search-do-keystroke (w)
  123.   (declare (special *default-command-p*))
  124.   (let* ((key-code *current-keystroke*)
  125.          (char *current-character*))
  126.     (if (and (or (%i> key-code 32)
  127.                  (eql char #\return)
  128.                  (eql char #\tab)
  129.                  (eql char #\space))
  130.              (neq char #\rubout)
  131.              (eql key-code (logand #xff key-code)))
  132.       (i-search-add-char w char)
  133.       (progn
  134.         (ed-push-mark w (car *i-search-original-pos*))
  135.         (remove-shadowing-comtab w)
  136.         ;(collapse-selection w t) ; I like this but Mac weenies probably wont
  137.         (run-fred-command w (keystroke-function w key-code))
  138.         (setq *default-command-p* t)
  139.         (i-search-all-done w)))))
  140.  
  141. )
  142.  
  143. (provide "I-SEARCH-PATCH")
  144.  
  145.  
  146.  
  147.  
  148. (in-package "COMMON-LISP-USER")
  149.  
  150.  
  151. ;;;================================================================
  152. ;;;Variables ======================================================
  153. ;;;================================================================
  154.  
  155. (defvar *keystroke-recorder-installed?* nil
  156.   "Non-nil when *old-fred-keystroke-hook* is set.")
  157.  
  158. (defvar *old-fred-keystroke-hook* nil
  159.   "The last value of *fred-keystroke-hook*.")
  160.  
  161. (defvar *saved-keystroke-names* ()
  162.   ;;
  163.   ;; I use keystroke names (not codes) to simplify editing, viewing, and
  164.   ;; saving.
  165.   ;;
  166.   "The stack of keystroke names or named-macro-names that
  167. save-and-call-current-keystroke and call-named-macro maintain.")
  168.  
  169. (defvar *named-macros* ()
  170.   "A list of named-macro objects. Maintained by name-and-save-last-macro")
  171.  
  172. (defvar *last-called-macro* nil
  173.   "The named-macro last called by call-named-macro.")
  174.  
  175.  
  176. ;;;================================================================
  177. ;;;named-macro ADT ================================================
  178. ;;;================================================================
  179.  
  180. (defmethod make-named-macro ((name string) (keystroke-names list))
  181.   "Returns a new named-macro object."
  182.   ;;
  183.   (cons name keystroke-names))
  184.  
  185.  
  186. (defmethod named-macro-name ((named-macro list))
  187.   "Returns the name component of NAMED-MACRO."
  188.   ;;
  189.   (first named-macro))
  190.  
  191.  
  192. (defmethod named-macro-keystroke-names ((named-macro list))
  193.   "Returns the keystroke-names component of NAMED-MACRO."
  194.   ;;
  195.   (rest named-macro))
  196.  
  197.  
  198. ;;;================================================================
  199. ;;;Top-level keyboard macro functions =============================
  200. ;;;================================================================ 
  201.  
  202. (defun name-last-kbd-macro ()
  203.   "Assign a name to the last keyboard macro defined."
  204.   ;;
  205.   (let* ((reversed-ks-names (reverse *saved-keystroke-names*))
  206.          (length (length reversed-ks-names))
  207.          (string (substitute #\¶ #\Return (format nil "~A" reversed-ks-names)))
  208.          (too-long-length 20)
  209.          (too-long? (> (length string) too-long-length))
  210.          (name (get-string-from-user
  211.                 (format
  212.                  nil
  213.                  "Enter a name for the last recorded macro:~&~A item~P: ~A~A):"
  214.                  length length
  215.                  (if too-long? (subseq string 0 too-long-length) string)
  216.                  (if too-long? "…" "")))))
  217.     (save-named-macro (make-named-macro name reversed-ks-names))))
  218.  
  219.  
  220. (defmethod insert-kbd-macro ((named-macro list) (stream stream))
  221.   "Insert in buffer the definition of kbd macro NAMED-MACRO into WINDOW, as
  222. Lisp code."
  223.   ;;
  224.   (format stream "(save-named-macro (make-named-macro ~S '~S))"
  225.           (named-macro-name named-macro)
  226.           (named-macro-keystroke-names named-macro)))
  227.  
  228.  
  229. (defun insert-all-kbd-macros ()
  230.   "Runs insert-kbd-macro on all named macros."
  231.   ;;
  232.   (let ((stream (front-window)))
  233.     (cond (*named-macros*
  234.            (format stream "~&;;; The current named macros:~&(progn~&")
  235.            (dolist (named-macro *named-macros*)
  236.              (insert-kbd-macro named-macro stream)
  237.              (terpri stream))
  238.            (princ ")" stream)
  239.            (fred-update stream))
  240.           (t
  241.            (format t "~&No currently defined macros.")))))
  242.  
  243.  
  244. (defmethod delete-kbd-macro ((named-macro list))
  245.   "Deletes the definition of kbd macro NAMED-MACRO and updates the macro menus."
  246.   ;;
  247.   (setf *named-macros* (delete named-macro *named-macros* :test #'equal))
  248.   (update-macro-menus))
  249.  
  250.  
  251. (defun delete-all-kbd-macros ()
  252.   "Runs delete-kbd-macro on all named macros."
  253.   ;;
  254.   (when (y-or-n-dialog (format nil "Delete all ~A macro~P?"
  255.                                (length *named-macros*) (length *named-macros*))
  256.                        :yes-text "Delete All")
  257.     (map nil #'delete-kbd-macro *named-macros*)))
  258.  
  259.  
  260. (defmethod save-named-macro ((named-macro list))
  261.   "Saves NAMED-MACRO on *named-macros* and updates the macro menus,
  262. replacing any macros with the same name."
  263.   ;;
  264.   ;; Remove those with the same names.
  265.   ;;
  266.   (setf *named-macros*
  267.         (delete-if #'(lambda (current-named-macro)
  268.                        (string-equal (named-macro-name named-macro)
  269.                                      (named-macro-name current-named-macro)))
  270.                    *named-macros*))
  271.   (push named-macro *named-macros*)
  272.   (update-macro-menus))
  273.  
  274.  
  275. (defmethod call-named-macro ((named-macro list) (window fred-mixin)
  276.                               &key (save-as-last? t))
  277.   "Calls the first macro named by NAME passing it WINDOW, saves its name
  278. to *saved-keystroke-names* if *keystroke-recorder-installed?*, and sets
  279. *last-called-macro* to it. If SAVE-AS-LAST? is non-nil (the default) then
  280. sets *last-called-macro* to NAMED-MACRO."
  281.   ;;
  282.   (when save-as-last?
  283.     (setf *last-called-macro* named-macro))
  284.   (run-keystroke-name-list (named-macro-keystroke-names named-macro) window)
  285.   (when *keystroke-recorder-installed?*
  286.     (push (named-macro-name named-macro)
  287.           *saved-keystroke-names*)))
  288.  
  289.  
  290. (defmethod run-keystroke-name-list :around
  291.   ((keystroke-name-list list) (window fred-mixin))
  292.   "An :around method that repeats the usual if there is a FRED prefix."
  293.   ;;
  294.   (let (;; Fred-prefix-argument is nil if no prefix, (number) if c-u
  295.         ;; prefix used, and number otherwise.
  296.         ;;
  297.         (prefix-argument? (fred-prefix-argument window))
  298.         (prefix-value (fred-prefix-numeric-value window)))
  299.     ;;
  300.     ;; Kludge: first do one empty Fred run to eliminate its automatic
  301.     ;; prefixing if a prefix is present.
  302.     ;;
  303.     (when prefix-argument? (run-fred-command window #'identity))
  304.     (dotimes (count (if prefix-argument?
  305.                       prefix-value      ;prefix specified so use it
  306.                       1))               ; no prefix so use default
  307.       (call-next-method))))
  308.  
  309.  
  310. (defmethod run-keystroke-name-list ((keystroke-name-list list)
  311.                                     (window fred-mixin))
  312.   "Calls each function bound to keystroke name in KEYSTROKE-NAME-LIST in
  313. order, passing WINDOW to each. If any of KEYSTROKE-NAME-LIST's elements are
  314. strings that name named macros then that macro is called."
  315.   ;;
  316.   (let ((ccl::*processing-events* t))   ; don't look at user events until done
  317.     (unwind-protect
  318.       (run-keystroke-namelist-internal keystroke-name-list window)
  319.       (ccl::remove-shadowing-comtab window))))
  320.  
  321.  
  322. (defmethod run-keystroke-namelist-internal ((keystroke-name-list list)
  323.                                            (window fred-mixin))
  324.   "Calls each function bound to keystroke name in KEYSTROKE-NAME-LIST in
  325. order, passing WINDOW to each. If any of KEYSTROKE-NAME-LIST's elements are
  326. strings that name named macros then that macro is called."
  327.   ;;
  328.   (dolist (keystroke-name keystroke-name-list)
  329.     (cond
  330.      ((stringp keystroke-name)
  331.       ;;
  332.       ;; KEYSTROKE-NAME might name a keyboard macro so call it if it does,
  333.       ;; noting that this should not be saved as the last macro.
  334.       ;;
  335.       (let ((named-macro (find keystroke-name *named-macros*
  336.                                :test #'string-equal :key #'named-macro-name)))
  337.         (when named-macro
  338.           (call-named-macro named-macro window :save-as-last? nil))))
  339.      (t
  340.       ;;
  341.       ;; KEYSTROKE-NAME doesn't name a macro so "run" the keystroke.
  342.       ;;
  343.       ;;
  344.       ;; Following code is adapted from Bill's patch of 7-May-91.
  345.       ;;
  346.       (locally (declare (special ccl::*current-character*))
  347.        (let* ((ccl::*current-keystroke* (keystroke-code keystroke-name))
  348.               ;; The docs say bits 0-7 of the code are the character, so mask
  349.               ;; the others off to get the character for
  350.               ;; ccl::*current-character*.
  351.               (keystroke-char
  352.                (coerce (logand #x000000FF (keystroke-code keystroke-name))
  353.                        'character))
  354.               ;; This is the previous best way I could think of to get the
  355.               ;; character from a keystroke-name or code:
  356.               ;(keystroke-char (etypecase keystroke-name
  357.               ;                  (list (first (remove-if-not #'characterp keystroke-name)))
  358.               ;                  (character keystroke-name)))
  359.               (ccl::*current-character* keystroke-char)
  360.               (tab (or (fred-shadowing-comtab window)
  361.                        (slot-value window 'ccl::comtab))))
  362.          (declare (special ccl::*current-keystroke* ccl::*processing-events*
  363.                            ccl::*current-character*))
  364.          ;;
  365.          (run-fred-command
  366.           window (keystroke-function window ccl::*current-keystroke* tab))))))))
  367.  
  368.  
  369. ;;;================================================================
  370. ;;;Functions the Fred methods and key bindings use ================
  371. ;;;================================================================
  372.  
  373. (defun save-and-call-current-keystroke (window-or-item)
  374.   "The function bound to *fred-keystroke-hook* by ed-start-kbd-macro."
  375.   ;;
  376.   ;; Save the keystroke name bound to *current-keystroke* on
  377.   ;; *saved-keystroke-names* then call its function.
  378.   ;;
  379.   (push (keystroke-name *current-keystroke*) *saved-keystroke-names*)
  380.   (run-fred-command window-or-item
  381.                     (keystroke-function window-or-item *current-keystroke*)))
  382.  
  383.  
  384. (defun install-keystroke-recorder ()
  385.   (unless *keystroke-recorder-installed?*
  386.     (setf *keystroke-recorder-installed?* t
  387.           *old-fred-keystroke-hook* *fred-keystroke-hook*
  388.           *fred-keystroke-hook* #'save-and-call-current-keystroke)))
  389.  
  390.  
  391. (defun deinstall-keystroke-recorder ()
  392.   (when *keystroke-recorder-installed?*
  393.     (setf *fred-keystroke-hook* *old-fred-keystroke-hook*
  394.           *old-fred-keystroke-hook* nil
  395.           *keystroke-recorder-installed?* nil)))
  396.  
  397.  
  398. ;;;
  399. ;;; Make the minibuffer show when we're recording.
  400. ;;;
  401.  
  402. #| ;;; This wasn't called when I thought it would be.
  403.  
  404. (defmethod set-mini-buffer :around
  405.   ((window-or-item fred-mixin) (string string) &rest format-args)
  406.   "Precedes the usual with 'Macro: ' if *keystroke-recorder-installed?*."
  407.   ;;
  408.   (if *keystroke-recorder-installed?*
  409.     (concatenate 'string "Macro: " (call-next-method))
  410.     (call-next-method)))
  411. |#
  412.  
  413.  
  414. ;;;================================================================
  415. ;;;Fred methods and key bindings ==================================
  416. ;;;================================================================
  417.  
  418. (defmethod ed-start-kbd-macro ((w fred-mixin))
  419.   "Record subsequent keyboard input, defining a keyboard macro."
  420.   ;;
  421.   (cond (*keystroke-recorder-installed?*
  422.          ;; Already recording so beep and set minibuffer.
  423.          (set-mini-buffer w "Already recording.")
  424.          (ed-beep))
  425.         (t
  426.          (setf *saved-keystroke-names* ())
  427.          (install-keystroke-recorder)
  428.          (set-mini-buffer w "Recording…"))))
  429.  
  430.  
  431. (defmethod cheezy-find-all-keys ((function-name symbol) (window fred-mixin))
  432.   "Returns a list of keystroke name *sequences* bound to FUNCTION-NAME."
  433.   ;;
  434.   ;; I'm *sure* there is a better way…
  435.   ;;
  436.   (let ((shadowing-comtab (fred-shadowing-comtab window))     ;right?
  437.         (keystroke-codes ())     ;a list of sequences of ks-codes
  438.         l-comtab-keys)
  439.     (when (and shadowing-comtab
  440.                (setf l-comtab-keys (comtab-find-keys shadowing-comtab function-name)))
  441.       (setf keystroke-codes (append (keystroke-name l-comtab-keys) keystroke-codes)))
  442.     (when (setf l-comtab-keys (comtab-find-keys (slot-value window 'ccl::comtab)
  443.                                                 function-name))
  444.       (setf keystroke-codes (append (keystroke-name l-comtab-keys)
  445.                                     keystroke-codes)))
  446.     (when (setf l-comtab-keys (comtab-find-keys *comtab* function-name))
  447.       (setf keystroke-codes (append (keystroke-name l-comtab-keys) keystroke-codes)))
  448.     (when (setf l-comtab-keys (comtab-find-keys *control-x-comtab* function-name))
  449.       (dolist (code l-comtab-keys)
  450.         (push (list '(:control #\x) (keystroke-name code))
  451.               keystroke-codes)))
  452.     ;;
  453.     keystroke-codes))
  454.  
  455.  
  456. (defmethod ed-end-kbd-macro ((w fred-mixin) &key (from-menu? nil))
  457.   "Finish defining a keyboard macro. If FROM-MENU? is non-nil then remove
  458. the last two "
  459.   ;;
  460.   (cond (*keystroke-recorder-installed?*
  461.          (deinstall-keystroke-recorder)
  462.          (set-mini-buffer w "Recording… Done.")
  463.          ;;
  464.          ;; Remove from *saved-keystroke-names* all keystrokes bound to
  465.          ;; ed-end-kbd-macro.
  466.          ;;
  467.          (when (not from-menu?)
  468.            (let* ((ks-list *saved-keystroke-names*)
  469.                   (ks-list-len (length ks-list))
  470.                   (rev-ks-list (reverse ks-list))
  471.                   subseq)
  472.              (dolist (ks-name-seq (cheezy-find-all-keys 'ed-end-kbd-macro w))
  473.                ;; Get the last |ks-name-seq| chars from rev-ks-list.
  474.                (setf subseq
  475.                      (subseq rev-ks-list (- ks-list-len (length ks-name-seq))
  476.                              ks-list-len))
  477.                (when (equal ks-name-seq subseq)
  478.                  ;; Ks-name-seq has a list of |ks-name-seq| kestroke names
  479.                  ;; that begins *saved-keystroke-names* so remove that many
  480.                  ;; from the front
  481.                  (dotimes (c (length ks-name-seq))
  482.                    (pop *saved-keystroke-names*))))))
  483.          ;;
  484.          ;; Old version:
  485.          ;;
  486.          ;; Remove (#\) (:CONTROL #\x) from *saved-keystroke-names* if
  487.          ;; necessary. Problem: I don't know how many to remove and I can't
  488.          ;; get comtab-find-keys to work. For now just blast away two and
  489.          ;; hope!
  490.          ;(when (and (not from-menu?)
  491.          ;           (>= (length *saved-keystroke-names*) 2))
  492.          ;  (pop *saved-keystroke-names*)
  493.          ;  (pop *saved-keystroke-names*))
  494.          ;
  495.          )
  496.         (t
  497.          ;; Not recording so beep and set minibuffer.
  498.          (set-mini-buffer w "Not recording.")
  499.          (ed-beep))))
  500.  
  501.  
  502. (defmethod ed-call-new-kbd-macro ((w fred-mixin))
  503.   "Call the new keyboard macro that you defined with ed-start-kbd-macro."
  504.   ;;
  505.   (run-keystroke-name-list (reverse *saved-keystroke-names*) w))
  506.  
  507.  
  508. (defmethod ed-call-last-kbd-macro ((w fred-mixin))
  509.   "Call the last keyboard macro that you ran with call-named-macro."
  510.   ;;
  511.   (cond (*last-called-macro*
  512.          (call-named-macro *last-called-macro* w))
  513.         (t
  514.          (set-mini-buffer w "Must run a named macro first.")
  515.          (ed-beep))))
  516.  
  517.  
  518. ;;; put the commands on standard (gemacs) keystrokes:
  519.  
  520. (comtab-set-key *control-x-comtab* #\( 'ed-start-kbd-macro)
  521. (comtab-set-key *control-x-comtab* #\) 'ed-end-kbd-macro)
  522. (comtab-set-key *control-x-comtab* #\e 'ed-call-new-kbd-macro)
  523. (comtab-set-key *control-x-comtab* '(:control :meta #\e) 'ed-call-last-kbd-macro)
  524.  
  525.  
  526. ;;;================================================================
  527. ;;;Menu setup =====================================================
  528. ;;;================================================================
  529.  
  530. ;;;
  531. ;;; The menu interface to macros allows running, listing, deleting, and
  532. ;;; inserting named-macro objects. It has a top-level menu named "Macros"
  533. ;;; with three hierarchial submenus that list all named macros: "Run",
  534. ;;; "Insert", and "Delete".
  535. ;;;
  536.  
  537. ;;; The following three menus' contents are upated by update-macro-menus:
  538.  
  539. (defvar *macro-run-menu* (make-instance 'menu :menu-title "Run"))
  540. (defvar *macro-insert-menu* (make-instance 'menu :menu-title "Insert"))
  541. (defvar *macro-delete-menu* (make-instance 'menu :menu-title "Delete"))
  542.  
  543. (defvar *macro-menu* nil "A menu of useful Fred keyboard macro commands.")
  544.  
  545. (defvar *record-menu-item* nil
  546.   "An item whose string is either 'Record' or 'End recording' which provides a
  547. non-keyboard method of starting and stopping recording.")
  548.  
  549.  
  550. (defun install-macro-menu ()
  551.   "Deinstalls the old 'Macros' menu and installs a new one."
  552.   ;;
  553.   (when (find-menu "Macros")
  554.     (menu-deinstall (find-menu "Macros")))
  555.   (setf *macro-menu*
  556.         (make-instance
  557.          'menu :menu-title "Macros"
  558.          :menu-items
  559.          (list *macro-run-menu* *macro-insert-menu* *macro-delete-menu*
  560.                (make-instance 'menu-item :menu-item-title "-")   ;line
  561.                (setf *record-menu-item*
  562.                      (make-instance 'menu-item
  563.                                     :menu-item-title "Recording"
  564.                                     :menu-item-action
  565.                                     #'(lambda ()
  566.                                         ;; Toggle recording according to
  567.                                         ;; its current state.
  568.                                         (if *keystroke-recorder-installed?*
  569.                                           (ed-end-kbd-macro (front-window)
  570.                                                             :from-menu? t)
  571.                                           (ed-start-kbd-macro (front-window))))))
  572.                (make-instance 'menu-item
  573.                               :menu-item-title "Run New"
  574.                               :menu-item-action
  575.                               #'(lambda ()
  576.                                   (ed-call-new-kbd-macro (front-window))))
  577.                (make-instance 'menu-item
  578.                               :menu-item-title "Name New"
  579.                               :menu-item-action #'name-last-kbd-macro)
  580.                (make-instance 'menu-item :menu-item-title "-")   ;line
  581.                (make-instance 'menu-item
  582.                               :menu-item-title "Run Last"
  583.                               :menu-item-action
  584.                               #'(lambda ()
  585.                                   (ed-call-last-kbd-macro (front-window))))
  586.                (make-instance 'menu-item
  587.                               :menu-item-title "Insert All"
  588.                               :menu-item-action #'insert-all-kbd-macros)
  589.                (make-instance 'menu-item
  590.                               :menu-item-title "Delete All"
  591.                               :menu-item-action #'delete-all-kbd-macros))))
  592.   ;;
  593.   ;; Define the update functions.
  594.   ;;
  595.   (defmethod menu-update ((menu (eql *macro-menu*)))
  596.     "Enables the *macro-run-menu* and *macro-insert-menu* submenus if the
  597. front window is typep 'fred-window or its current-key-handler is
  598. non-nil. Otherwise disables them."
  599.     ;;
  600.     (let ((front-window (front-window)))
  601.       (cond ((or (typep front-window 'fred-window)
  602.                  (current-key-handler front-window))
  603.              ;; A fred-window or fred-mixin so enable macros.
  604.              (menu-enable *macro-run-menu*)
  605.              (menu-enable *macro-insert-menu*))
  606.             (t
  607.              ;; Not a fred-window so disable macros.
  608.              (menu-disable *macro-run-menu*)
  609.              (menu-disable *macro-insert-menu*)))
  610.       (call-next-method)))
  611.  
  612.   
  613.   (defmethod menu-item-update ((menu-item (eql *record-menu-item*)))
  614.     "Corrects *record-menu-item*'s checkmark according to whether
  615. *keystroke-recorder-installed?*."
  616.     ;;
  617.     (set-menu-item-check-mark
  618.      menu-item (if *keystroke-recorder-installed?* t nil)))
  619.  
  620.   ;;
  621.   ;; Install *macro-menu*.
  622.   ;;
  623.   (menu-install *macro-menu*))
  624.  
  625.  
  626. (install-macro-menu)
  627.  
  628.  
  629. (defun update-macro-menus ()
  630.   "Updates *macro-run-menu*, *macro-insert-menu*, and *macro-delete-menu*
  631. to list all named macros."
  632.   ;;
  633.   ;; Remove all old menu-items.
  634.   ;;
  635.   (apply #'remove-menu-items *macro-run-menu* (menu-items *macro-run-menu*))
  636.   (apply #'remove-menu-items *macro-insert-menu* (menu-items *macro-insert-menu*))
  637.   (apply #'remove-menu-items *macro-delete-menu* (menu-items *macro-delete-menu*))
  638.   ;;
  639.   (dolist (named-macro (sort (copy-list *named-macros*)
  640.                              #'string< :key #'named-macro-name))
  641.     (add-menu-items
  642.      *macro-run-menu*
  643.      (make-instance 'menu-item :menu-item-title (named-macro-name named-macro)
  644.                     :menu-item-action
  645.                     (let ((named-macro named-macro))
  646.                       #'(lambda () (call-named-macro named-macro (front-window))))))
  647.     (add-menu-items
  648.      *macro-insert-menu*
  649.      (make-instance 'menu-item :menu-item-title (named-macro-name named-macro)
  650.                     :menu-item-action
  651.                     (let ((named-macro named-macro))
  652.                       #'(lambda () (insert-kbd-macro named-macro (front-window))))))
  653.     (add-menu-items
  654.      *macro-delete-menu*
  655.      (make-instance 'menu-item :menu-item-title (named-macro-name named-macro)
  656.                     :menu-item-action
  657.                     (let ((named-macro named-macro))
  658.                       #'(lambda () (delete-kbd-macro named-macro)))))))